home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Demos / Widget / Warrow.stklos next >
Encoding:
Text File  |  1996-01-20  |  7.4 KB  |  184 lines
  1. ;;;;
  2. ;;;; STk adaptation of the Tk widget demo.
  3. ;;;;
  4. ;;;; This demonstration script creates a canvas widget that displays a
  5. ;;;; large line with an arrowhead whose shape can be edited interactively.
  6. ;;;;
  7. (require "Tk-classes")
  8.  
  9. (define (demo-arrow)
  10.   (define w (make-demo-toplevel "arrow"
  11.                 "Arrowhead Editor Demonstration"
  12.                 "This widget allows you to experiment with different widths and arrowhead shapes for lines in canvases.  To change the line width or the shape of the arrowhead, drag any of the three boxes attached to the oversized arrow.  The arrows on the right give examples at normal scale.  The text at the bottom shows the configuration options as you'd enter them for a canvas line item."))
  13.   
  14.   (define a         8)
  15.   (define b         10)
  16.   (define c         3)
  17.   (define width     2)
  18.   (define motion-proc    #f)
  19.   (define x1         40)
  20.   (define x2         350)
  21.   (define y         150)
  22.   (define small-tips    '(5 5 2))
  23.   (define cnv         (make <Canvas> :parent w :width 500 :height 350 
  24.                   :relief "sunken" :border-width 2))
  25.   (define box1         #f)
  26.   (define box2         #f)
  27.   (define box3         #f)
  28.   (define current-box    #f)
  29.  
  30.   ;;; arrowSetup  regenerates all the text and graphics in the canvas
  31.   ;;; window.  It's called when the canvas is initially created, and also
  32.   ;;; whenever any of the parameters of the arrow head are changed
  33.   ;;; interactively.
  34.   (define (arrow-setup cnv)
  35.  
  36.     ;; Create the arrow and outline.
  37.     (canvas-delete cnv "all")
  38.     
  39.     (apply make <Line> :parent cnv
  40.                   :coords (list x1 y x2 y) 
  41.                :width (* 10 width)
  42.                :arrow-shape (list (* 10 a) (* 10 b) (* 10 c))
  43.                :arrow "last"
  44.                (if (> (winfo 'depth cnv) 1)
  45.                 `(:fill "SkyBlue1")
  46.                 `(:fill black 
  47.                   :stipple ,(& "@" *stk-library* "/images/grey.25"))))
  48.  
  49.     (let ((xtip    (- x2 (* 10 b)))
  50.       (delta-y (+ (* 10 c) (* 5 width))))
  51.       (make <Line> :parent cnv 
  52.                :coords (list x2 y xtip (+ y delta-y) (- x2 (* 10 a))
  53.                  y xtip (- y delta-y) x2 y)
  54.            :width 2
  55.            :cap-style "round")
  56.  
  57.       ;;;Create the boxes for reshaping the line and arrowhead.
  58.       (set! box1 (make <Rectangle> :parent cnv 
  59.                :coords (list (- x2 (* 10 a) +5) (- y 5)
  60.                      (- x2 (* 10 a) -5) (+ y 5))
  61.                :fill "white" :tags '("box" "box1")))
  62.       (set! box2 (make <Rectangle> :parent cnv 
  63.                :coords (list (- xtip 5) (- y delta-y +5)
  64.                      (+ xtip 5) (- y delta-y -5))
  65.                :fill "white" :tags '("box" "box2")))
  66.       (set! box3 (make <Rectangle> :parent cnv 
  67.                :coords (list (- x1 5) (- y (* 5 width) +5)
  68.                      (+ x1 5) (- y (* 5 width) -5))
  69.                :fill "white" :tags '("box" "box3")))
  70.  
  71.       ;; Create three arrows in actual size with the same parameters
  72.       (make <Line> :parent cnv :coords (list (+ x2 50) 0 (+ x2 50) 1000) :width 2)
  73.       (let ((tmp (+ x2 100)))
  74.     (make <Line> :parent cnv :coords (list tmp (- y 125) tmp (- y 75)) 
  75.           :width width :arrow "both" :arrow-shape (list a b c))
  76.     (make <Line> :parent cnv :coords (list (- tmp 25) y (+ tmp 25) y)
  77.           :width width :arrow "both" :arrow-shape (list a b c))
  78.     (make <Line> :parent cnv :coords (list (- tmp 25) (+ y 75) 
  79.                            (+ tmp 25) (+ y 125))
  80.           :width width :arrow "both" :arrow-shape (list a b c)))
  81.       ;; Create a bunch of other arrows and text items showing the
  82.       ;; current dimensions.
  83.       (let ((tmp (+ x2 10)))
  84.     (make <Line> :parent cnv :coords (list tmp (- y (* 5 width)) 
  85.                            tmp (- y delta-y))
  86.           :arrow "both" :arrow-shape small-tips)
  87.     (make <Text-item> :parent cnv :coords (list (+ x2 15) 
  88.                             (- y delta-y (* -5 c)))
  89.           :text c :anchor "w"))
  90.  
  91.       (let ((tmp (- x1  10)))
  92.     (make <Line> :parent cnv :coords (list tmp (- y (* 5 width)) 
  93.                            tmp (+ y (* 5 width)))
  94.           :arrow "both" :arrow-shape small-tips)
  95.     (make <Text-item> :parent cnv :coords (list (- x1 15) y)
  96.           :text width :anchor "e"))
  97.       
  98.       (let ((tmp (+ y (* 5 width) (* 10 c) 10)))
  99.     (make <Line> :parent cnv :coords (list (- x2 (* 10 a)) tmp x2 tmp)
  100.           :arrow "both" :arrow-shape small-tips)
  101.     (make <Text-item> :parent cnv :coords (list (- x2 (* 5 a)) (+ tmp 5))
  102.           :text a :anchor "n"))
  103.  
  104.       (let ((tmp (+ y (* 5 width) (* 10 c) 35)))
  105.     (make <Line> :parent cnv :coords (list (- x2 (* 10 b)) tmp x2 tmp)
  106.           :arrow "both" :arrow-shape small-tips)
  107.     (make <Text-item> :parent cnv :coords (list (- x2 (* 5 b)) (+ tmp 5))
  108.           :text b :anchor "n"))
  109.  
  110.       (make  <Text-item> :parent cnv :coords (list x1 310) 
  111.          :text (format #f ":width ~A" width) :anchor "w"
  112.          :font "-*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*")
  113.       (make  <Text-item> :parent cnv :coords (list x1 330) 
  114.          :text (format #f ":arrow-shape '~A" (list a b c)) :anchor "w"
  115.          :font "-*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*"))
  116.     (if current-box 
  117.     (set! (fill current-box) (if (> (winfo 'depth cnv) 1) "red" "black"))))
  118.  
  119.   (define (activate-box)
  120.     (let ((box (find-items cnv 'withtag "current")))
  121.       (when (pair? box)
  122.     (set! current-box (car box))
  123.     (set! (fill current-box) (if (> (winfo 'depth cnv) 1) "red" "black")))))
  124.   
  125.   (define (deactivate-box)
  126.     (set! (fill current-box) "white")
  127.     (set! current-box #f))
  128.  
  129.   ;; arrow-move-1  is called for each mouse motion event on box1 (the
  130.   ;; one at the vertex of the arrow).  It updates the controlling parameters
  131.   ;; for the line and arrowhead.
  132.   (define (arrow-move-1 cnv new-x new-y)
  133.     (let ((new-a (inexact->exact (floor (/ (- x2 -5 (canvas-x cnv new-x)) 10)))))
  134.       (if (< new-a 0)  (set! new-a 0))
  135.       (if (> new-a 25) (set! new-a 25))
  136.       (unless (= new-a a)
  137.     (move box1 (* 10 (- a new-a)) 0)
  138.     (set! a new-a))))
  139.  
  140.   ;; arrow-move-2  is called for each mouse motion event on box2 (the
  141.   ;; one at the trailing tip of the arrowhead). It updates the controlling
  142.   ;; parameters for the line and arrowhead.
  143.   (define (arrow-move-2 cnv new-x new-y)
  144.     (let ((new-b (inexact->exact (floor (/ (- x2 -5 (canvas-x cnv new-x)) 10))))
  145.       (new-c (inexact->exact (floor (/ (- y  -5 (round (canvas-y cnv new-y))
  146.                           (* 5 width)) 10)))))
  147.       (if (< new-b 0)  (set! new-b 0))
  148.       (if (> new-b 25) (set! new-b 25))
  149.       (if (< new-c 0)  (set! new-c 0))
  150.       (if (> new-c 20) (set! new-c 20))
  151.       (unless (and (= new-b b) (= new-c c))
  152.     (move box2 (* 10 (- b new-b)) (* 10 (- c new-c)))
  153.     (set! b new-b)
  154.     (set! c new-c))))
  155.  
  156.   ;; arrow-move-3 is called for each mouse motion event on box3 (the
  157.   ;; one that controls the thickness of the line).  It updates the
  158.   ;; controlling parameters for the line and arrowhead.
  159.   (define (arrow-move-3 cnv new-x new-y)
  160.    (let ((new-w (inexact->exact (floor (/ (- y -2 (canvas-y cnv new-y)) 5)))))
  161.      (if (< new-w 0)  (set! new-w 0))
  162.      (if (> new-w 20) (set! new-w 20))
  163.      (unless (= new-w width)
  164.        (move box3 0 (* 5 (- width new-w)))
  165.        (set! width  new-w))))
  166.  
  167.   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  168.   
  169.   (arrow-setup cnv)
  170.   (pack cnv :expand #t :fill "both")
  171.  
  172.   ;;; Bindings
  173.   (bind cnv "box"  "<Enter>"        activate-box)
  174.   (bind cnv "box"  "<Leave>"        deactivate-box)
  175.   (bind cnv "box"  "<B1-Enter>"     (lambda () 'nop))
  176.   (bind cnv "box"  "<B1-Leave>"     (lambda () 'nop))
  177.   (bind cnv "box"  "<B1-Motion>"    (lambda (x y) 
  178.                       (if motion-proc (motion-proc cnv x y))))
  179.   (bind cnv "box1" "<1>"            (lambda () (set! motion-proc arrow-move-1)))
  180.   (bind cnv "box2" "<1>"            (lambda () (set! motion-proc arrow-move-2)))
  181.   (bind cnv "box3" "<1>"            (lambda () (set! motion-proc arrow-move-3)))
  182.   (bind cnv "<Any-ButtonRelease-1>" (lambda () (arrow-setup cnv))))
  183.  
  184.